home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / PNL Libraries / MyMemory.p < prev    next >
Encoding:
Text File  |  1994-09-11  |  3.0 KB  |  152 lines  |  [TEXT/PJMM]
  1. unit MyMemory;
  2.  
  3. interface
  4.  
  5. {$IFC undefined THINK_Pascal}
  6.     uses
  7.         Types;
  8. {$ENDC}
  9.  
  10.     function MNewPtr (var p: univ ptr; size: longInt): OSErr;
  11.     function MNewHandle (var h: univ handle; size: longInt): OSErr;
  12.     function MSetPtrSize (var p: univ ptr; size: longInt): OSerr;
  13.     function MSetHandleSize (var h: univ handle; size: longInt): OSerr;
  14.     procedure MDisposePtr (var p: univ ptr);
  15.     procedure MDisposeHandle (var h: univ handle);
  16.     procedure MFill (p: univ ptr; size: longInt; val: integer);
  17.     procedure MFillLong (p: univ ptr; size: longInt; val: longInt);
  18. { ptr and size must be long alligned }
  19.     procedure LockHigh (h: univ handle);
  20.     procedure HLockState (h: handle; var state: SignedByte);
  21.     procedure HUnlockState (h: handle; var state: SignedByte);
  22.  
  23. implementation
  24.  
  25. {$IFC undefined THINK_Pascal}
  26.     uses
  27.         Memory;
  28. {$ENDC}
  29.  
  30. {$SETC debug_memory=0 }
  31.  
  32.     const
  33.         fill_byte = $E5; { odd, big, negative, easily recognizable }
  34.  
  35.     function CheckPtr (p: ptr): boolean;
  36.     begin
  37. {$IFC debug_memory }
  38.         if p = nil then begin
  39.             DebugStr('Memory Error!');
  40.         end;
  41. {$ENDC}
  42.         CheckPtr := p <> nil;
  43.     end;
  44.  
  45.     function MNewPtr (var p: univ ptr; size: longInt): OSErr;
  46.         var
  47.             err: OSErr;
  48.     begin
  49.         p := NewPtr(size);
  50.         err := MemError;
  51. {$IFC debug_memory }
  52.         if (err = noErr) then begin
  53.             MFill(p, GetPtrSize(p), fill_byte);
  54.         end;
  55. {$ENDC}
  56.         MNewPtr := err;
  57.     end;
  58.  
  59.     function MNewHandle (var h: univ handle; size: longInt): OSErr;
  60.         var
  61.             err: OSErr;
  62.     begin
  63.         h := NewHandle(size);
  64.         err := MemError;
  65. {$IFC debug_memory }
  66.         if (err = noErr) then begin
  67.             MFill(h^, GetHandleSize(h), fill_byte);
  68.         end;
  69. {$ENDC}
  70.         MNewHandle := err;
  71.     end;
  72.  
  73.     function MSetPtrSize (var p: univ ptr; size: longInt): OSerr;
  74.     begin
  75.         SetPtrSize(p, size);
  76.         MSetPtrSize := MemError;
  77.     end;
  78.  
  79.     function MSetHandleSize (var h: univ handle; size: longInt): OSerr;
  80.     begin
  81.         SetHandleSize(h, size);
  82.         MSetHandleSize := MemError;
  83.     end;
  84.  
  85.     procedure MDisposePtr (var p: univ ptr);
  86.     begin
  87.         if CheckPtr(p) then begin
  88. {$IFC debug_memory }
  89.             MFill(p, GetPtrSize(p), fill_byte);
  90. {$ENDC}
  91.             DisposPtr(p);
  92.         end;
  93.         p := nil;
  94.     end;
  95.  
  96.     procedure MDisposeHandle (var h: univ handle);
  97.     begin
  98.         if h <> nil then begin
  99. {$IFC debug_memory }
  100.             MFill(h^, GetHandleSize(h), fill_byte);
  101. {$ENDC}
  102.             DisposeHandle(h);
  103.             h := nil;
  104.         end;
  105.     end;
  106.  
  107.     procedure MFill (p: univ ptr; size: longInt; val: integer);
  108.         var
  109.             i: longInt;
  110.     begin
  111.         if CheckPtr(p) then begin
  112.             for i := longInt(p) to longInt(p) + size - 1 do begin
  113.                 ptr(i)^ := val;
  114.             end;
  115.         end;
  116.     end;
  117.  
  118.     procedure MFillLong (p: univ ptr; size: longInt; val: longInt);
  119.         type
  120.             longPtr = ^longInt;
  121.         var
  122.             i: longInt;
  123.     begin
  124.         if CheckPtr(p) then begin
  125.             i := longInt(p);
  126.             while size > 3 do begin
  127.                 longPtr(i)^ := val;
  128.                 i := i + 4;
  129.                 size := size - 4;
  130.             end;
  131.         end;
  132.     end;
  133.  
  134.     procedure LockHigh (h: univ handle);
  135.     begin
  136.         MoveHHi(h);
  137.         HLock(h);
  138.     end;
  139.  
  140.     procedure HLockState (h: handle; var state: SignedByte);
  141.     begin
  142.         state := HGetState(h);
  143.         HLock(h);
  144.     end;
  145.  
  146.     procedure HUnlockState (h: handle; var state: SignedByte);
  147.     begin
  148.         state := HGetState(h);
  149.         HUnlock(h);
  150.     end;
  151.  
  152. end.